perm filename SCNR5.F4[MU5,LCS]1 blob
sn#107300 filedate 1974-06-19 generic text, type T, neo UTF8
BLOCK DATA
COMMON/X/P(30),J,L,CNT(25),BT,MK,VX(35),PL(30),DF,IXIN,NINS,TF,
1XT(25),ROFF(25),V(2000),NP(25),PCH(25,32),INST(26),DUR(26),IALL,
1DURX,AMPFAC,IT(30),I,OP1,INUM(25),BG(80),INP(72),TP,
1CVTX,ISCA(12),IDAT(11),IQ(25),SCAL(86),MU5(14)
1,LIST(78),INVIS(25),RDEV(25),IBLA,KSLA,ICOM,ISEMI,IMIN,ISTAR
1,IEL,IPLUS
C INST AND DUR MUST HAVE 1 MORE THAN MAX NUM OF INSTS IN ARRAYS!!!
DATA ICOM/','/,IMIN/'-'/,ISEMI/';'/,IBLA/' '/,KSLA/'/'/
1,ISTAR/'*'/,IPLUS/'+'/,IEL/'L'/
DATA ISCA/'C','P','D','N','E','F','U','G','S','A','V','B'/
DATA IDAT/'0','1','2','3','4','5','6','7','8','9','.'/
DATA MU5/'T','C','2','N','V','R','3','4','X','I','H','M','D','S'/
C OUT, OSC, AD2, RAN, ENV, STR, AD3, AD4, MLT, SET, RAH.
C (CONT AND FLT NOT USED.)
DATA SCAL/'C1','CS1','D1','DS1','E1','F1','FS1','G1',
1 'GS1','A1','AS1','B1','C2','CS2','D2','DS2','E2',
1 'F2','FS2','G2','GS2','A2','AS2','B2','C3','CS3','D3','DS3',
1 'E3','F3','FS3','G3','GS3','A3', 'AS3','B3','C4','CS4',
1'D4','DS4','E4','F4','FS4','G4','GS4','A4','AS4','B4','C5','CS5'
1,'D5','DS5','E5','F5','FS5','G5','GS5','A5','AS5','B5','C6','CS6'
1,'D6','DS6','E6','F6','FS6','G6','GS6','A6','AS6','B6','C7','CS7'
1,'D7','DS7','E7','F7','FS7','G7','GS7','A7','AS7','B7','R','END'/
END
C ***** SCANNER *************************
SUBROUTINE SCANR
DIMENSION IP(30)
COMMON/X/P(30),J,L,CNT(25),BT,MK,VX(35),PL(30),DF,IXIN,NINS,TF,
1XT(25),ROFF(25),V(2000),NP(25),PCH(25,32),INST(26),DUR(26),IALL,
1DURX,AMPFAC,IT(30),I,OP1,INUM(25),BG(80),INP(72),TP,
1CVTX,ISCA(12),IDAT(11),IQ(25),SCAL(86),MU5(14)
1,LIST(78),INVIS(25),RDEV(25),IBLA,KSLA,ICOM,ISEMI,IMIN,ISTAR
1,IEL,IPLUS
COMMON/SC/ML,JJ,NNUM,NFLG,JA,ISUB,CODE,IAMP,M
COMMON /Q/ BNW(40),NWZ
COMMON/FINE/LK
EQUIVALENCE(IF,ISCA(6)),(ISS,ISCA(9)),(IE,ISCA(5)),(IDOT,IDAT(11))
1 ,(IEN,ISCA(4)),(IP,P),(IR,MU5(6)),(II,MU5(10)),(IXX,MU5(9))
NNUM=-1
ISKP=0
JJ=0
XMINUS=1.
999 IDECI=-1
M=0
2799 N=INP(ML)
899 ML=ML+1
IF(N.EQ.ISEMI)GO TO 751
IF(N.NE.IBLA.AND.N.NE.ICOM)GO TO 510
4702 IF(ISKP)202,2799,2799
510 IF(JA.LT.0)GO TO 70
C********** MAY 22,71
DO 77 K=1,12
IF(N.NE.ISCA(K))GO TO 77
IF(K.NE.2.AND.K.NE.4)GO TO 511
NSWCH=K-4
GO TO 2799
C TO SWITCH ALWAYS USE OCT.# /PBF4/ /NE5/ P=PROXIMITY, N=NORMAL
C ************ MAY 22,71
511 NNUM=K
JJ=JJ+1
NFLG=-1
N=INP(ML)
IF(N.NE.IF)GO TO 410
NNUM=NNUM-1
GO TO 610
410 IF(N.NE.ISS)GO TO 3410
NNUM=NNUM+1
610 ML=ML+1
N=INP(ML)
3410 IF(N.NE.II)GO TO 371
C 'END' OR 'FINE' WILL END INST.
C******** MAY 20,71
3411 VX(JJ)=10000.
IF(DUR(LK).LT.0)DUR(LK)=1000.
IAMP=-1
RETURN
371 IF(N.EQ.ISEMI.OR.N.EQ.IBLA)GO TO 5410
DO 177 KN=2,8
IF(N.NE.IDAT(KN))GO TO 177
JSCA=KN-2
ML=ML+1
GO TO 2410
177 CONTINUE
GO TO 6410
5410 KN=-1
6410 IF(NSWCH.EQ.0)GO TO 2410
IF(KN.LT.0)GO TO 7410
IF(N.EQ.IPLUS)NOLD=NOLD+6
IF(N.EQ.IMIN)NOLD=NOLD-6
C /B/B-/ JUMPS DOWN OCT., /B/B+/ UP OCT.
7410 IF(NOLD-NNUM.GT.5.AND.JSCA.LT.7)JSCA=JSCA+1
IF(NOLD-NNUM.LT.-5.AND.JSCA.GT.0)JSCA=JSCA-1
C WILL JUMP TO NEAREST NOTE *********** MAY 22,71
2410 VX(JJ)=JSCA*12+NNUM
NOLD=NNUM
C ********** MAY 22,71
4410 NNUM=-2
IF(INP(ML).EQ.ISEMI)RETURN
C ABOVE FINDS SCALE NOTES; IF NSWCH=0 OCT. NUM WILL STICK UNTIL RESET
GO TO 310
C *********MAY 22,71
77 CONTINUE
70 IF(N.NE.IMIN)GO TO 71
XMINUS=-1.
GO TO 2799
210 JJ=JJ+1
IF(JJ.EQ.1)GO TO 3310
C****** MAY 19,71
XMINUS=1.
VX(JJ)=0
C 'X N1,N2' MAY REPLACE 'REP N1,N2'. N2=0 BECOMES N2=2
GO TO 310
71 IF(N.EQ.IXX)GO TO 210
IF(N.EQ.IR)GO TO 73
1410 DO 78 K=1,11
IF(N.NE.IDAT(K))GO TO 78
ISKP=-1
IF(N.NE.IDOT)GO TO 79
IDECI=M
GO TO 75
79 M=M+1
IP(M)=K-1
GO TO 75
78 CONTINUE
IF(N.NE.IF)GO TO 781
C 'END' OR 'FINE' WILL END INST.
JJ=1
GO TO 3411
781 IF(N.EQ.KSLA)N=ISEMI
C FOR MOTIVIC TRANFORMATIONS
75 IF(N.NE.ISEMI.AND.INP(ML).NE.1)GO TO 2799
751 IF(ISKP.EQ.0)RETURN
202 IF(IDECI.NE.-1)GO TO 302
IDECI=0
GO TO 402
302 IDECI=M-IDECI
402 KN=0
IEXP=M-1
IF(M.LT.1)M=1
DO 171 K=1,M
KV=10**IEXP
IF(IEXP.EQ.0)KV=1
KN=KN+IP(K)*KV
171 IEXP=IEXP-1
A=10**IDECI
IF(IDECI.EQ.0)A=1.
JJ=JJ+1
VX(JJ)=KN/A*XMINUS
IF(ISUB.EQ.1)RETURN
IF(CODE.NE.-22.)XMINUS=1.
C ONLY ONE - NEEDED FOR RHY.COMPOSITE
1310 IF(INP(ML).NE.1)GO TO 310
VX(JJ+1)=VX(JJ)*2.
JJ=JJ+1
ML=ML+1
GO TO 1310
206 ML=ML+2
3310 VX(1)=-99.
C******** MAY 19,71
310 ISKP=0
IF(N.NE.ISEMI)GO TO 999
RETURN
73 JJ=JJ+1
IF(INP(ML).EQ.IE)GO TO 206
C NEXT IS FOR A REST ('R')
VX(JJ)=85.
GO TO 4410
END
SUBROUTINE BGSORT(BW)
C THIS SORTS BG TIMES SO NONE ARE DUPLICATED IN BNW ARRAY.
C ALLOWS 100 BG TIMES.
COMMON /Q/ BNW(40),NWZ
DO 5308 K=1,NWZ
X=BNW(K)-.0001
Y=X+.0002
C ROUND-OFF NONSENSE
5308 IF(BW.GT.X.AND.BW.LT.Y)RETURN
NWZ=NWZ+1
BNW(NWZ)=BW
C FOR ROUND-OFF
RETURN
END
SUBROUTINE INSTS
COMMON/X/P(30),J,L,CNT(25),BT,MK,VX(35),PL(30),DF,IXIN,NINS,TF,
1XT(25),ROFF(25),V(2000),NP(25),PCH(25,32),INST(26),DUR(26),IALL,
1DURX,AMPFAC,IT(30),I,OP1,INUM(25),BG(80),INP(72),TP,
1CVTX,ISCA(12),IDAT(11),IQ(25),SCAL(86),MU5(14)
1,LIST(78),INVIS(25),RDEV(25),IBLA,KSLA,ICOM,ISEMI,IMIN,ISTAR
1,IEL,IPLUS
COMMON/SC/ML,JJ,NNUM,NFLG,JA,ISUB,CODE,IAMP,M
COMMON /Q/ BNW(40),NWZ
COMMON/RW/NWRITE,NDEC,LPT,DEBUG
DIMENSION IPBFV(4),IPL(30)
DATA IPBFV/'P','B','F','V'/
EQUIVALENCE (V2,V(2)),(V3,V(3)),(V4,V(4)),(VX2,VX(2)),(VX1,VX(1))
1,(VX3,VX(3)),(V5,V(5))
1,(VX4,VX(4)),(VX5,VX(5)),(VX6,VX(6))
1,(ISS,ISCA(9))
1,(IEM,MU5(12)),(IR,MU5(6))
1,(IG,ISCA(8)),(IPL,PL)
C IF DIMENS. ARE CHANGED, CHANGE KZY. ALL CHNGS MUST BE MULTS OF KZY.
C SET INST(KZY+1), CHECK BG, CHECK BLOCK DATA VALUES.
TYPE 3773
3773 FORMAT(' TYPE FILE NAME'/)
ACCEPT 2107,IBM
C********** ABOVE 3 FOR PDP10 *********
2107 FORMAT(A5)
IF(IBM.EQ.IBLA)IBM='ILIST'
C***** TO READ IN TEST FILE *******
NWRITE=21
REWIND NWRITE
C 21=DSK1 ON PDP10. 'REWIND' RESETS IT.
REWIND 1
C********** PDP10 RESET **********
CALL IFILE(1,IBM)
NDEC=1
C SET NDEC TO 5 FOR IBM.**** 1=PDP10 DSK ****
3000 FORMAT(1X72A1)
ML=2
LPAR=0
ISUB=0
8002 JA=-1
ICT=0
LPT=3
C*******PDP10 LPT=3 ***********
IF(INP(ML-1).EQ.KSLA)GO TO 101
8001 READ(NDEC,5900)KW,INP
C REMOVE KW ETC. FOR CARDS OR NO LINE NUMBERS.
7006 WRITE(LPT,3000)INP
IF(INP(1).EQ.IBLA)GO TO 8001
C BLANK LINES MAY APPEAR IN INSTS.
ML=1
101 IZ=15
N=INP(ML+2)
DO 2900 K=1,14
2900 IF(N.EQ.MU5(K))IZ=K
IF(IZ.NE.1)GO TO 3900
IF(INP(ML).EQ.IEM)IZ=9
IF(INP(ML).EQ.ISS)IZ=10
IF(INP(ML+1).EQ.IR)IZ=12
C 9=MLT 10=SET 12=SRT
GO TO 4900
3900 IF(INP(ML).EQ.IG)GO TO 2899
C JUMP FOR GEN
4900 ML=ML+3
IF(IZ.LE.11)GO TO 9015
C JUMP IF IT'S A UNIT GENERATOR
IZ=IZ-11
GO TO (9018,9014,6900,1129),IZ
C SRT END INS SCORE
C ABOVE FOR UNIT GENERATORS
6900 Y=36.
C Y IS FOR AUTOMATIC LAST PARAM NUM.
CALL SCANR
12 V2=2.
V3=VX1
V4=VX2
L=4
C L=TOTAL WD CNT.
GO TO 72
5 L=JJ+4
DO 9021 K=5,L
9021 V(K)=VX(K-4)
GO TO(72,172,72,172,172,72,72,72,72,72,172,72,72),IZ
172 NL=1
IF(IZ.EQ.4)NL=3
IF(IZ.EQ.11)NL=2
DO 472 K=1,NL
Y=Y-1.
L=L+1
472 V(L)=Y
IF(IZ.EQ.2)L=9
C ABOVE ALLOWS A 'V' TO BE PUT AT END OF OSC.
72 M=L-1
WRITE(NWRITE)M,(V(K),K=2,L)
6006 WRITE(LPT,5552)M,(V(K),K=2,L)
IF(LPAR)2129,8002,8002
5552 FORMAT(I5,(14F9.2))
9014 L=3
GO TO 72
2899 ML=ML+3
CALL SCANR
6 V2=3.
NL=3
L=JJ+ICT+2
GO TO 8006
60 NL=ICT+1
L=JJ+ICT
8006 DO 9022 K=NL,L
9022 V(K)=VX(K-NL+1)
DO 90221 K=1,72
N=INP(K)
IF(N.EQ.ISTAR)GO TO 72
IF(N.EQ.KSLA)CALL EXIT
90221 IF(N.EQ.ISEMI)GO TO 90222
90222 READ(1,5900)K,INP
C READS SECOND LINE OF GEN INPUT. NO! SLASHES WITH GEN.
C ****** NO MORE!! THAN TWO LINES PER GEN ALLOWED.!!!!!******
WRITE(LPT,3000)INP
IF(NL.NE.3)CALL EXIT
ML=1
ICT=ICT+L
CALL SCANR
GO TO 60
9015 M=1
DO 111 K=ML,72
N=INP(K)
IF(N.NE.ICOM)GO TO 1003
INP(K)=IBLA
GO TO 111
1003 IF(N.EQ.IBLA)GO TO 111
IF(N.EQ.KSLA)GO TO 1004
IF(N.NE.ISEMI)GO TO 1006
GO TO 1004
1006 DO 1005 J=1,4
IF(N.NE.IPBFV(J))GO TO 1005
IPL(M)=J
M=M+1
INP(K)=IBLA
GO TO 111
1005 CONTINUE
111 CONTINUE
1004 CALL SCANR
DO 21 K=1,JJ
X=VX(K)
GO TO (17,18,19,20),IPL(K)
C IPL(30) -- ROOM FOR 30 ARGS. IN INST DEF. LINE (SEVERAL UN.GENS.)
18 X=-X
GO TO 21
19 X=-X-100
GO TO 21
20 X=X+100
GO TO 21
17 X=X+2
C +2 SETS NUMBERS AHEAD FOR MUSIC5 NEEDS
21 VX(K)=X
V4=IZ+100
IF(IZ.EQ.6)LPAR=1
GO TO 5
C IZ+100=FORTR. UNIT GENS. IZ=MACH. LANG. UNIT GENS.
9018 V4=4.
CALL SCANR
8 V5=VX1
V2=11.
CVTX=V5
88 L=5
GO TO 72
1129 IF(LPAR)2129,2129,222
222 V2=12.
V4=8.
V5=1.
LPAR=-1
GO TO 88
2129 LPAR=0
DO 107 K=1,6
107 VX(K)=0
ML=ML+2
CALL SCANR
IXIN=1
TF=1
AMPFAC=1
DURX=19999.
IF(VX1.NE.0)IXIN=VX1
IF(VX2.NE.0)TF=VX2
IF(VX3.NE.0)AMPFAC=VX3
OP1=VX4
IF(VX5.NE.0)DURX=VX5
5900 FORMAT(I,72A1)
1107 FORMAT(I,A4,72A1)
C****REMOVE I IF NO LINE NUMBERS TO BE READ. ********
CALL RNDINT
DEBUG=VX6
C TYPE 'SCORE', TF=TEMPO FACTOR(0=1), AMPFAC=AMPL.FACT(0=1), OP1=SECONDS TO BE OMITTED,
C DURX=DUR AT CUTOFF, DEBUG>0 PRINTS 'V' ARRAY.
RETURN
END
C ROUTINE FOR TEMPERED SCALE PITCHES.
SUBROUTINE TMPSC
COMMON /X/ P(30),J,L,CNT(25),BT,MK,VX(35),PL(30),DF,IXIN,NINS,TF,
1 XT(25),ROFF(25),V(2000),NP(25),PCH(25,32),INST(26),DUR(26),IALL,
1DURX,AMPFAC,IT(30),I,OP1,INUM(25),BG(80),INP(72),TP,
1CVTX,ISCA(12),IDAT(11),IQ(25),SCAL(86),MU5(14)
1,LIST(78),INVIS(25),RDEV(25),IBLA,KSLA,ICOM,ISEMI,IMIN,ISTAR
1,IEL,IPLUS
EQUIVALENCE (Z,LIST(3))
Z=IFIX(Z)
Z=30.868*2**(Z/12.)
C FINDS TEMPERED PITCH FROM NOTE NUMBER.
C COULD BE ADAPTED TO MICROTONE ROUTINE.
RETURN
END
SUBROUTINE RANR(VX,K)
C FOR RAN. SELEC. OF NOTES. FINDS HIGHEST NOTE.
DIMENSION VX(1)
X=VX(K)
Y=VX(K+1)
IF(X.GT.Y)VX(K)=X+.999
IF(Y.GE.X)VX(K+1)=Y+.999
RETURN
END
SUBROUTINE ACCL(RA,KA,RC,XA,Z,Y,X,XT,YY,RB,W)
4020 RD=1
IF(RA.LT.0)RD=-1.
RA=RA*RD
IF(KA.EQ.0)RA=RA-RC
W=RA
RB=W
IF(W.LE.Z)GO TO 2020
IF(Z.NE.0)GO TO 3020
RA=RA/Y
RB=-1.
RC=0
GO TO 8020
3020 W=Z
RC=W+RC
GO TO 24
2020 RC=0
24 IF(X.NE.Y)GO TO 424
RA=W/X
GO TO 8020
C DUR OF TMP+BG TIME OF TMP - NOTE VALUE - BG TIME OF NOTE. CHN=TBG.
424 RAX=XT
RA=(-2.*RAX+(4.*RAX**2+8.*YY*W)**.5)/(2.*YY)
XT=RAX+YY*RA
8020 IF(KA.EQ.0)RA=RA+XA
KA=1
RETURN
END
SUBROUTINE ACCL2(XA,RA,K,ZPAR,CHN,ZZ,KA,X,Y,Z,YY,PR)
COMMON/X/P(30),J,L,CNT(25),BT,MK,VX(35),PL(30),DF,IXIN,NINS,TF,
1XT(25),ROFF(25),V(2000),NP(25),PCH(25,32),INST(26),DUR(26),IALL,
1DURX,AMPFAC,IT(30),I,OP1,INUM(25),BG(80),INP(72),TP,
1CVTX,ISCA(12),IDAT(11),IQ(25),SCAL(86),MU5(14)
1,LIST(78),INVIS(25),RDEV(25),IBLA,KSLA,ICOM,ISEMI,IMIN,ISTAR
1,IEL,IPLUS
2011 XA=RA
IF(K.GT.1)GO TO 9920
K=I-6
ZPAR=-9900.-CHN-ZZ
DO 3011 KL=8,I
IF(V(K).EQ.ZPAR.AND.V(K+1).EQ.990000.)GO TO 9920
3011 K=K-1
9920 W=ZZ
IF(V(K+3).LT.0)K=K+3
C ABOVE IS FOR TYPED IN ITMPO CHANGES
KA=K+3
ZZ=V(KA)
C DUR OF NEXT TEMPI
X=V(KA+1)
Y=V(KA+2)
213 KA=0
Z=ZZ
CALL SQYY(YY,X,Y,Z)
C GETS VALUE OF YY
CHN=CHN+W
XT(J)=X
IF(KA.EQ.1)Z=0
RA=PR
KA=0
K=K+3
RETURN
END
SUBROUTINE SQYY(YY,X,Y,Z)
YY=2.*Z/(X+Y)
IF(YY.NE.0)YY=2.*(Z-X*YY)/YY**2
RETURN
END